home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / mapforms (code walker).sea / mapforms (code walker) / templates.lisp < prev   
Encoding:
Text File  |  1992-04-21  |  6.7 KB  |  144 lines  |  [TEXT/CCL2]
  1. ;;; -*- Mode:LISP; Package:Language-Tools; Syntax:Common-Lisp -*-
  2. ;;;>>SHARED-MESSAGE
  3. ;;;>
  4. ;;;>******************************************************************************************
  5. ;;;>    This may only be used as permitted under the license agreement under
  6. ;;;>    which it has been distributed, and in no other way.
  7. ;;;>******************************************************************************************
  8. ;;;>
  9. ;;;>
  10. ;;; Written May 1982 by David A. Moon for use by the Common Lisp community
  11. ;;; Revised April 1983
  12.  
  13. ;;; Tools for source code analysis: special form templates
  14.  
  15. ;;;--- Missing Common-Lisp things:
  16. ;;; FLET, LABELS, MACROLET  (require local-macro environment in MAPFORMS!)
  17. ;;; LOCALLY (requires new declare stuff)
  18. ;;; THE has a template but isn't done right
  19.  
  20. ;;; The things with ZL: package prefixes might be generated by macros
  21. ;;; or something, so keep them in for now.
  22.  
  23. ;;; Temporary until the templates are in the source code of the special forms
  24. ;;; Also the templates needed by Maclisp will go here
  25.  
  26. (DEFUN STORE-TEMPLATE (FUNCTION TEMPLATE)
  27.   (PUSH (CONS FUNCTION TEMPLATE) *ARG-TEMPLATE-ALIST*))
  28.  
  29. (STORE-TEMPLATE 'AND '(COND (REPEAT TEST) RETURN))    ;sort of
  30. (STORE-TEMPLATE 'BLOCK '(BLOCK . BODY))
  31. (STORE-TEMPLATE 'BREAK '(QUOTE TEST))
  32.  
  33. ;ARBITRARY here is to prevent moving complex code in or out of the scope of the catch
  34. (STORE-TEMPLATE 'CATCH '(EVAL ARBITRARY . BODY))
  35. (STORE-TEMPLATE 'ZL:*CATCH '(EVAL ARBITRARY . BODY))
  36. (STORE-TEMPLATE 'ZL:COMMENT 'QUOTE)
  37. (STORE-TEMPLATE 'COND '(COND (REPEAT (TEST . BODY))))
  38.  
  39. ;These templates are not actually used, except by the :SPECIAL-FORM option
  40. (STORE-TEMPLATE 'DO '(LOOP))
  41. (STORE-TEMPLATE 'DO* '(LOOP))
  42. (STORE-TEMPLATE 'ZL:DO-NAMED '(LOOP))
  43. (STORE-TEMPLATE 'ZL:DO*-NAMED '(LOOP))
  44.  
  45. (STORE-TEMPLATE 'FUNCTION '(CALL))
  46. (STORE-TEMPLATE 'GO '(GO))
  47. (STORE-TEMPLATE 'IF '(COND TEST RETURN . BODY))
  48. (STORE-TEMPLATE 'LET '(PARALLEL-LET DECLARE . BODY))
  49. (STORE-TEMPLATE 'LET* '(((REPEAT LET)) DECLARE . BODY))
  50. (STORE-TEMPLATE 'LET-IF '(TEST PARALLEL-LET DECLARE . BODY))  ;yes, not COND!
  51. (STORE-TEMPLATE 'LET-VALUE '((ORDER (2 LET) (1 RETURN) (3 EFFECT))))
  52. (STORE-TEMPLATE 'ZL:MULTIPLE-VALUE '(((REPEAT (IF NULL QUOTE SET))) EVAL))
  53. (STORE-TEMPLATE 'MULTIPLE-VALUE-BIND '(((REPEAT (IF NULL QUOTE LET))) EVAL
  54.                        DECLARE . BODY))
  55.  
  56. ;ARBITRARY here is to try to prevent interchange of 1-value variables and n-value forms
  57. (STORE-TEMPLATE 'MULTIPLE-VALUE-CALL '(ARBITRARY (REPEAT EVAL)))
  58. (STORE-TEMPLATE 'SYS:%MULTIPLE-VALUE-CALL-N '(CALL (REPEAT EVAL QUOTE)))
  59. (STORE-TEMPLATE 'MULTIPLE-VALUE-LIST '(EVAL))
  60. (STORE-TEMPLATE 'MULTIPLE-VALUE-PROG1 '(RETURN (REPEAT EFFECT)))
  61. (STORE-TEMPLATE 'OR '(COND (REPEAT RETURN)))  ;sort of
  62. (STORE-TEMPLATE 'PROG '(LOOP . (IF (OR (NULL (CAR EXPR)) (LISTP (CAR EXPR)))
  63.                    (ANONYMOUS-BLOCK PARALLEL-LET DECLARE . PROG)
  64.                    (BLOCK PARALLEL-LET DECLARE . PROG))))
  65. (STORE-TEMPLATE 'PROG* '(LOOP . (IF (OR (NULL (CAR EXPR)) (LISTP (CAR EXPR)))
  66.                     (ANONYMOUS-BLOCK ((REPEAT LET)) DECLARE . PROG)
  67.                     (BLOCK ((REPEAT LET)) DECLARE . PROG))))
  68. (STORE-TEMPLATE 'PROG1 '(RETURN (REPEAT EFFECT)))
  69. (STORE-TEMPLATE 'PROG2 '(EFFECT RETURN (REPEAT EFFECT)))
  70. (STORE-TEMPLATE 'PROGN 'BODY)
  71.  
  72. ;ARBITRARY in next two is to allow for the special-variable bindings that occur
  73. (STORE-TEMPLATE 'PROGV '(EVAL EVAL ARBITRARY . BODY))
  74. (STORE-TEMPLATE 'PROGW '(EVAL ARBITRARY . BODY))
  75. (STORE-TEMPLATE 'QUOTE '(QUOTE))
  76.  
  77. ;These aren't actually used, it's really done procedurally, but they need
  78. ;to be here so we know these are special forms, not functions.
  79. ;Note that the ZL RETURN takes n arguments, even though the CL RETURN takes only 2
  80. (STORE-TEMPLATE 'RETURN 'BODY)
  81. (STORE-TEMPLATE 'RETURN-FROM '(RETURN-FROM . BODY))
  82. (STORE-TEMPLATE 'COMPILER:RETURN-FROM-T 'BODY)
  83.  
  84. ;This isn't actually used, because it was too hard to make ORDER inside REPEAT work!
  85. ;---last is returned.  But also eval....
  86. (STORE-TEMPLATE 'SETQ '((REPEAT (ORDER (2 SET) (1 EVAL)))))
  87.  
  88. ;Maclisp brain damage...
  89. (STORE-TEMPLATE 'ZL:SIGNP '(QUOTE EVAL))
  90. (STORE-TEMPLATE 'ZL:SSTATUS '(ARBITRARY . QUOTE))    ;No evaled subforms in Lisp machine!
  91. (STORE-TEMPLATE 'ZL:STATUS 'QUOTE)            ;No evaled subforms in Lisp machine!
  92. #-3600
  93. (STORE-TEMPLATE 'ZL:STORE '((ORDER (2 EVAL) (1 EVAL) (3 ARBITRARY))))
  94. (STORE-TEMPLATE 'TAGBODY '(LOOP . PROG))
  95. (STORE-TEMPLATE 'THE '(QUOTE RETURN))        ;just ignore the type dcl
  96. (STORE-TEMPLATE 'THROW '(EVAL (REPEAT EFFECT) EVAL ARBITRARY))
  97. (STORE-TEMPLATE 'UNWIND-PROTECT '(RETURN (REPEAT EFFECT)))
  98. (STORE-TEMPLATE 'VALUES '((REPEAT RETURN)))
  99. (STORE-TEMPLATE 'VARIABLE-BOUNDP '(SYMEVAL))
  100.  
  101. ;This would count as a SET because the variable could potentially be set indirectly
  102. ;through the locative produced, however we already assume that arbitrary side-effects
  103. ;always affect local variables.  So count it as a SYMEVAL: that we don't assume
  104. ;a side-effect just from computing the location; the side-effect is deferred
  105. ;until somebody actually does something unpredictable with that location.  This matters!
  106. (STORE-TEMPLATE 'VARIABLE-LOCATION '(SYMEVAL))
  107. (STORE-TEMPLATE 'DBG:VARIABLE-LOCATION-MAYBE '(SYMEVAL)) ;commented as a kludge
  108. (STORE-TEMPLATE 'VARIABLE-MAKUNBOUND '(SET))
  109. (STORE-TEMPLATE 'WITH-STACK-LIST '(((ORDER (2 LET) (1 (REPEAT EVAL)))) . BODY))
  110. (STORE-TEMPLATE 'WITH-STACK-LIST* '(((ORDER (2 LET) (1 (REPEAT EVAL)))) . BODY))
  111.  
  112. ;Special forms that can appear at top level
  113. ;Put templates on these in case we want to grovel through whole files
  114. (STORE-TEMPLATE 'COMPILER:ADD-OPTIMIZER 'QUOTE)
  115. (STORE-TEMPLATE 'DECLARE 'QUOTE)
  116. (STORE-TEMPLATE 'SI:DEFCONST-1 '(SET EVAL QUOTE))
  117. (STORE-TEMPLATE 'SI:DEFVAR-1 '(SET EVAL QUOTE))
  118. (STORE-TEMPLATE 'DEF '(QUOTE (REPEAT EFFECT) EVAL))
  119. (STORE-TEMPLATE 'DEFF '(QUOTE EVAL))
  120. (STORE-TEMPLATE 'DEFPROP '(QUOTE QUOTE QUOTE))
  121. ;DEFUN is procedural
  122. (STORE-TEMPLATE 'EVAL-WHEN '(QUOTE (REPEAT RETURN)))
  123. (STORE-TEMPLATE 'ZL:EVAL-WHEN '(QUOTE (REPEAT RETURN)))
  124. ;MACRO is procedural
  125. (STORE-TEMPLATE 'SI:SETQ-IF-UNBOUND '(SET EVAL))
  126. (STORE-TEMPLATE 'SPECIAL 'QUOTE)
  127. (STORE-TEMPLATE 'UNSPECIAL 'QUOTE)
  128.  
  129. ;---- Zetalisp...
  130. ;;Not needed I guess: (each line for a different reason)
  131. ;*EXPR *FEXPR *LEXPR CC:ARRAY* CC:CLOSED CC:EXPR-HASH CC:GENPREFIX CC:NOTYPE CC:QUOTED-ARGS
  132. ;FIXNUM INCLUDE
  133. ;COMPILER:DEFMIC GRINDEF LOGIN-SETQ PACKAGE-DECLARE TRACE UNTRACE
  134. ; SET-COMTAB-RETURN-UNDO
  135. ;ARRAY FUNCTIONAL-ALIST LEXICAL-CLOSURE MULTIPLE-VALUE-RETURN
  136. ;--- won't need for these once templates are really on the debug-info!
  137. ;SI:ADVISE-LET SI:ADVISE-MULTIPLE-VALUE-LIST SI:ADVISE-PROG SI:ADVISE-PROGN SI:ADVISE-SETQ
  138. ; SI:ENCAPSULATION-LET
  139. ; SI:PKG-ADVERTISE-SYMBOLS SI:PKG-BORROW-SYMBOLS SI:PKG-EXTERN-SYMBOLS
  140. ; SI:PKG-FORWARD-ALIAS SI:PKG-FORWARD-SYMBOLS SI:PKG-INDIRECT-ALIAS SI:PKG-INDIRECT-SYMBOLS
  141. ; SI:PKG-INTERN-SYMBOLS SI:PKG-KEYWORD-SYMBOLS SI:PKG-MYREFNAME-DECL SI:PKG-REF-DECL
  142. ; SI:PKG-SHADOW-SYMBOLS SI:PKG-USE-PACKAGE
  143. ;SYS:FIXUP-METHOD-FROM-FASD
  144.